home *** CD-ROM | disk | FTP | other *** search
/ Merciful 4 / Merciful - Disc 4.iso / rexx / whirlpool.pprx < prev    next >
Text File  |  1996-11-02  |  13KB  |  489 lines
  1. /* Personal Paint Amiga Rexx script - Copyright © 1996 Cloanto Italia srl */
  2.  
  3. /* $VER: Whirlpool.pprx 1.1 */
  4.  
  5. /** ENG
  6.  This script creates a text "whirlpool": a text string is rendered
  7.  along an elliptical path, using a vector font in the current foreground
  8.  color.
  9.  
  10.  This is a "tool macro": the mouse can be used to define an ellipse.
  11.  When the mouse button is released, a settings requester is
  12.  displayed. The settings include: font, text string, text size, start angle,
  13.  antialiasing, etc.
  14.  
  15.  If a single point (pixel), rather than an area, is selected, a requester
  16.  with the previously-used area coordinates is displayed: the parameters can
  17.  be modified to fine-tune the appearance of the "whirlpool".
  18.  
  19.  The text string specified in the settings requester may contain color
  20.  control sequences, in the format "Esc[3#m" or "[#]", where # is a pen
  21.  number (0 .. 256). The default (initial) color is the current foreground
  22.  color.
  23. */
  24.  
  25. /** DEU
  26.  Mit diesem Skript läßt sich ein Text-"Whirlpool" erzeugen. Dazu wird
  27.  eine Textzeichenkette dem Verlauf eines elliptischen Pfades angepaßt,
  28.  wobei ein Vektorfont in der aktuellen Vordergrundfarbe verwendet wird.
  29.  
  30.  Dies ist ein sog. "Tool-Makro": Zunächst wird mit Hilfe der Maus
  31.  die Ellipse erstellt. Sobald die Maustaste losgelassen wird, öffnet
  32.  sich ein Dialogfenster zur Festlegung von Einstellungen für Font,
  33.  Textstring, Zeichengröße, Startwinkel, Kantenglättung, usw.
  34.  
  35.  Wird anstelle eines Bereichs lediglich ein einzelner Punkt selektiert,
  36.  so öffnet sich ein Dialogfenster mit den zuletzt verwendeten
  37.  Bereichskoordinaten, welche sich dann zur Feinabstimmung des
  38.  Erscheinungsbildes den Anforderungen entsprechend modifizieren lassen.
  39.  
  40.  Hinweis: Der im Dialogfenster "Einstellungen" festgelegte Textstring kann
  41.  auch mit Steuerzeichen zur Aktivierung einer bestimmten Farbe versehen
  42.  werden. Diese müssen im Format "Esc[3#m]" oder "[#]" vorliegen, wobei das
  43.  Rautenzeichen # die Stiftnummer (0...256) angibt. Standardmäßig ist die
  44.  aktuelle Vordergrundfarbe eingestellt.
  45. */
  46.  
  47. IF ARG(1, EXISTS) THEN
  48.     PARSE ARG PPPORT button x0 y0 .
  49. ELSE
  50.     EXIT 0  /* macro execution only */
  51.  
  52. ADDRESS VALUE PPPORT
  53. OPTIONS RESULTS
  54. OPTIONS FAILAT 10000
  55.  
  56. Get 'LANG'
  57. IF RESULT = 1 THEN DO        /* Deutsch */
  58.     txt_title_zone    = "Whirlpool-Bereich"
  59.     txt_gad_x0        = "Zentrum _X:"
  60.     txt_gad_y0        = "Zentrum _Y:"
  61.     txt_gad_radiusx   = "_Radius X:"
  62.     txt_gad_radiusy   = "Radiu_s Y:"
  63.     txt_title_set     = "Whirlpool-Einstellungen"
  64.     txt_gad_font      = "_Font:"
  65.     txt_gad_text      = "_Text:"
  66.     txt_string_text   = "Dies ist Text für den Whirlpool-Effekt."
  67.     txt_gad_sheight   = "_Höhe Anfang:"
  68.     txt_gad_eheight   = "Höhe _Ende:"
  69.     txt_gad_fall      = "_Gefälle %:"
  70.     txt_gad_sangle    = "Winkel A_nfang:"
  71.     txt_gad_aalias    = "_Kantenglättung:"
  72.     txt_gad_aalias0   = "Keine"
  73.     txt_gad_aalias1   = "Schwach"
  74.     txt_gad_aalias2   = "Mittel"
  75.     txt_gad_aalias3   = "Stark"
  76.     txt_err_nofonts   = "Vektorfonts nicht auffindbar"
  77.     txt_err_procss    = "Fehler bei Bildbearbeitung: "
  78.     txt_err_small     = "Ausgewählter Bereich ist zu klein"
  79.     txt_err_nomem     = "Zu wenig Speicher"
  80.     txt_err_oldclient = "Für dieses Skript_ist eine neuere Version_von Personal Paint erforderlich"
  81. END
  82. ELSE IF RESULT = 2 THEN DO    /* Italiano */
  83.     txt_title_zone    = "Zona spirale"
  84.     txt_gad_x0        = "Centro _X:"
  85.     txt_gad_y0        = "Centro _Y:"
  86.     txt_gad_radiusx   = "_Raggio X:"
  87.     txt_gad_radiusy   = "Raggi_o Y:"
  88.     txt_title_set     = "Parametri spirale"
  89.     txt_gad_font      = "_Font:"
  90.     txt_gad_text      = "_Testo:"
  91.     txt_string_text   = "Questo è un testo a spirale."
  92.     txt_gad_sheight   = "Altezza i_niziale:"
  93.     txt_gad_eheight   = "Altezza fina_le:"
  94.     txt_gad_fall      = "_Caduta %:"
  95.     txt_gad_sangle    = "Ang_olo iniziale:"
  96.     txt_gad_aalias    = "Antialia_s:"
  97.     txt_gad_aalias0   = "Nessuno"
  98.     txt_gad_aalias1   = "Basso"
  99.     txt_gad_aalias2   = "Medio"
  100.     txt_gad_aalias3   = "Alto"
  101.     txt_err_nofonts   = "Non vi sono font vettoriali"
  102.     txt_err_procss    = "Errore elaborazione immagine: "
  103.     txt_err_nomem     = "Memoria insufficiente"
  104.     txt_err_small     = "L'area definita è troppo piccola"
  105.     txt_err_oldclient = "Questa procedura richiede_una versione più recente_di Personal Paint"
  106. END
  107. ELSE DO            /* English */
  108.     txt_title_zone    = "Whirlpool Area"
  109.     txt_gad_x0        = "Center _X:"
  110.     txt_gad_y0        = "Center _Y:"
  111.     txt_gad_radiusx   = "_Radius X:"
  112.     txt_gad_radiusy   = "Radiu_s Y:"
  113.     txt_title_set     = "Whirlpool Settings"
  114.     txt_gad_font      = "_Font:"
  115.     txt_gad_text      = "_Text:"
  116.     txt_string_text   = "This is a whirlpool text."
  117.     txt_gad_sheight   = "_Start Height:"
  118.     txt_gad_eheight   = "_End Height:"
  119.     txt_gad_fall      = "Fa_ll %:"
  120.     txt_gad_sangle    = "Start _Angle:"
  121.     txt_gad_aalias    = "A_ntialias:"
  122.     txt_gad_aalias0   = "None"
  123.     txt_gad_aalias1   = "Low"
  124.     txt_gad_aalias2   = "Medium"
  125.     txt_gad_aalias3   = "High"
  126.     txt_err_nofonts   = "Vector fonts not found"
  127.     txt_err_procss    = "Image processing error: "
  128.     txt_err_small     = "The selected area is too small"
  129.     txt_err_nomem     = "Not enough memory"
  130.     txt_err_oldclient = "This script requires a newer_version of Personal Paint"
  131. END
  132.  
  133. Version 'REXX'
  134. IF RESULT < 7 THEN DO
  135.     RequestNotify 'PROMPT "'txt_err_oldclient'"'
  136.     EXIT 10
  137. END
  138.  
  139.  
  140. /* Ellipse Definition */
  141.  
  142. GetCurrentBrush
  143. savebsh = RESULT
  144. SetCurrentBrush 'RECTANGULAR WIDTH 1 HEIGHT 1'
  145.  
  146. prev_xp = x0
  147. prev_yp = y0
  148. drawn = 0
  149.  
  150. DO FOREVER
  151.     GetMousePosition
  152.     PARSE VAR RESULT xp yp .
  153.  
  154.     IF xp ~= prev_xp | yp ~= prev_yp | ~drawn THEN DO
  155.         IF drawn THEN
  156.             Undo
  157.         radiusx = ABS(x0 - xp)
  158.         radiusy = ABS(y0 - yp)
  159.         DrawEllipse x0 y0 radiusx radiusy
  160.  
  161.         prev_xp = xp
  162.         prev_yp = yp
  163.         drawn = 1
  164.     END
  165.     ELSE WaitForEvent
  166.  
  167.     GetMouseButton
  168.     IF RESULT ~= button THEN
  169.         LEAVE
  170. END
  171.  
  172. Undo
  173. SetCurrentBrush savebsh
  174.  
  175.  
  176. FreeBrush
  177. IF RC ~= 0 THEN
  178.     EXIT RC
  179.  
  180. /* Setting Requester */
  181.  
  182. def_font_path = "FONTS:"
  183. max_text_size = 8000
  184.  
  185. font_path = LoadSet('PP_VectorPath', def_font_path, 1, 0)
  186.  
  187.  
  188. ftot = 0
  189. vftfname = 'ENV:PP_VectorFonts'
  190. IF ~OPEN(fexists, vftfname) THEN DO
  191.     ADDRESS COMMAND 'List >'vftfname' 'font_path' PAT=#?.otag NOHEAD LFORMAT="%s"'
  192.     ADDRESS COMMAND 'Sort 'vftfname vftfname'.s'
  193.     IF RC = 0 THEN DO
  194.         ADDRESS COMMAND 'Delete >NIL: 'vftfname
  195.         ADDRESS COMMAND 'Rename >NIL: 'vftfname'.s' vftfname
  196.     END
  197. END
  198. ELSE CALL CLOSE(fexists)
  199.  
  200. IF OPEN('listfile', vftfname) THEN DO
  201.     DO FOREVER
  202.         fline = READLN('listfile')
  203.         IF EOF('listfile') THEN BREAK
  204.         ftot = ftot + 1
  205.         fontname.ftot = LEFT(fline, LENGTH(fline) - 5)
  206.     END
  207.     CALL CLOSE('listfile')
  208. END
  209.  
  210. IF ftot = 0 THEN DO
  211.     RequestNotify 'PROMPT "'txt_err_nofonts'"'
  212.     EXIT 10
  213. END
  214.  
  215.  
  216. IF radiusx < 2 & radiusy < 2 THEN DO        /* simple click */
  217.     lastpar = LoadSet('LastParams', '0 0 100 100')
  218.     PARSE VAR lastpar x0 y0 radiusx radiusy
  219.     Request '"'txt_title_zone'" ' ||,
  220.             '"INTSTR = ""'txt_gad_x0'"", 0, 32000, 'x0' ' ||,
  221.              'INTSTR = ""'txt_gad_y0'"", 0, 32000, 'y0' ' ||,
  222.              'INTSTR = ""'txt_gad_radiusx'"", 1, 32000, 'radiusx' ' ||,
  223.              'INTSTR = ""'txt_gad_radiusy'"", 1, 32000, 'radiusy' "'
  224.     IF RC ~= 0 THEN
  225.         EXIT RC
  226.     x0 = RESULT.1
  227.     y0 = RESULT.2
  228.     radiusx = RESULT.3
  229.     radiusy = RESULT.4
  230. END
  231.  
  232.  
  233. fntnum  = LoadSet('Font', 0)
  234. text    = LoadSet('Text', txt_string_text)
  235. height  = LoadSet('StartHeight', 50)
  236. eheight = LoadSet('EndHeight', 20)
  237. fallpc  = LoadSet('Fall', 100)
  238. angle   = LoadSet('StartAngle', 0)
  239. aalias  = LoadSet('Antialias', 0)
  240.  
  241. req = '"LIST = ""'txt_gad_font'"", 'ftot', 'fntnum', 20, 5'
  242. DO f = 1 TO ftot
  243.     req = req || ', ""' || fontname.f || '""'
  244. END
  245.  
  246. req = req ||,
  247.      ' VSPACE = 2 ' ||,
  248.       'STRING = ""'txt_gad_text'"", 'max_text_size', ""'text'"" ' ||,
  249.       'INTSTR = ""'txt_gad_sheight'"", 1, 32000, 'height' ' ||,
  250.       'INTSTR = ""'txt_gad_eheight'"", 1, 32000, 'eheight' ' ||,
  251.       'INTSTR = ""'txt_gad_fall'"", 0, 32000, 'fallpc' ' ||,
  252.       'VSPACE = 2 ' ||,
  253.       'SLIDE = ""'txt_gad_sangle'"", -360, 360, 'angle' ' ||,
  254.       'VSPACE = 2 ' ||,
  255.         'CYCLE = ""'txt_gad_aalias'"", 4, 'aalias', ""'txt_gad_aalias0'"", ""'txt_gad_aalias1'"", ""'txt_gad_aalias2'"", ""'txt_gad_aalias3'"" ' ||,
  256.       'VSPACE = 2 "'
  257.  
  258. LockGUI
  259. Request 'RESIZE COMPACT "'txt_title_set'" 'req
  260. IF RC = 0 THEN DO
  261.     fntnum  = RESULT.1 + 1
  262.     text    = RESULT.2
  263.     height  = RESULT.3
  264.     eheight = RESULT.4
  265.     fallpc  = RESULT.5
  266.     angle   = RESULT.6
  267.     aalias  = RESULT.7
  268.  
  269.     CALL SaveSet('Font', fntnum - 1)        /* setting persistence */
  270.     CALL SaveSet('Text', text)
  271.     CALL SaveSet('StartHeight', height)
  272.     CALL SaveSet('EndHeight', eheight)
  273.     CALL SaveSet('Fall', fallpc)
  274.     CALL SaveSet('StartAngle', angle)
  275.     CALL SaveSet('Antialias', aalias)
  276.     CALL SaveSet('LastParams', x0 y0 radiusx radiusy)
  277.  
  278.     IF radiusx < 1 | radiusy < 1 THEN DO
  279.         RequestNotify 'PROMPT "'txt_err_small'"'
  280.         len = 0
  281.     END
  282.  
  283.     angle = angle * 1000
  284.     IF angle < 0 THEN
  285.         angle = 360000 + angle
  286.     IF angle >= 360000 THEN
  287.         angle = angle - 360000
  288.  
  289.     GetPen 'FOREGROUND'
  290.     pen = RESULT
  291.     savepen = pen
  292.     SIGNAL ON Break_C
  293.  
  294.     tchar. = ''
  295.     tpen. = pen
  296.     len = ParseText(text, pen)
  297.  
  298.     GetImageAttributes 'DPIX'
  299.     dpix = RESULT
  300.     GetImageAttributes 'DPIY'
  301.     imgratio = dpix / RESULT
  302.  
  303.     rxdelta = (height * imgratio / 360000) * fallpc / 100
  304.     rydelta = (height / 360000) * fallpc / 100
  305.     hdelta = (height - eheight) / len
  306.  
  307.     DO c = 1 TO len
  308.         rx = TRUNC(radiusx + 0.5)
  309.         ry = TRUNC(radiusy + 0.5)
  310.         GetEllipsePoint x0 y0 rx ry angle 'IMAGERATIO'
  311.         PARSE VAR RESULT px py cangle .
  312.  
  313.         nextc = c + 1
  314.         VectorCharacter 'CHARACTER "'tchar.c || tchar.nextc'" FONTPATH "'font_path'" FONTNAME "'fontname.fntnum'" HEIGHT 'TRUNC(height + 0.5)' ANGLE 'cangle' ANTIALIAS 'aalias
  315.         IF RC = 0 THEN DO
  316.             PARSE VAR RESULT addx addy handlex handley . . nextwidth
  317.             GetBrushAttributes 'HANDLEX'
  318.             hx = RESULT
  319.             GetBrushAttributes 'HANDLEY'
  320.             hy = RESULT
  321.             SetBrushAttributes 'HANDLEX 'handlex' HANDLEY 'handley
  322.             SetPaintMode 'COLOR'
  323.             SetPen 'FOREGROUND' tpen.c
  324.  
  325.             IF aalias > 0 THEN DO
  326.                 Process 'IMAGE BRUSHMODE X0 'px' Y0 'py' FILTER "Brush Alpha Channel (Single)" NOFS'
  327.                 IF RC ~= 0 THEN DO
  328.                     IF RC ~= 5 THEN
  329.                         RequestNotify 'PROMPT "'txt_err_procss || RC'"'
  330.                     LEAVE
  331.                 END
  332.             END
  333.             ELSE PutBrush px py
  334.  
  335.             edgex = px - handlex + hx + addx
  336.             edgey = py - handley + hy + addy
  337.             dist = nextwidth % 2
  338.  
  339.             GetEllipseAngle x0 y0 rx ry edgex edgey dist angle 'IMAGERATIO INCREASING'
  340.             IF RC ~= 0 THEN
  341.                 LEAVE
  342.             new_angle = RESULT
  343.             IF new_angle >= angle THEN
  344.                 angle_step = new_angle - angle
  345.             ELSE
  346.                 angle_step = 360000 - angle + new_angle
  347.             angle = new_angle
  348.  
  349.             radiusx = radiusx - (rxdelta * angle_step)
  350.             radiusy = radiusy - (rydelta * angle_step)
  351.             IF radiusx < 1 | radiusy < 1 THEN
  352.                 LEAVE
  353.         END
  354.         ELSE DO
  355.             RequestNotify 'PROMPT "'txt_err_nomem'"'
  356.             LEAVE
  357.         END
  358.         height = height - hdelta
  359.     END
  360.     SetPen 'FOREGROUND' savepen
  361.     FreeBrush 'FORCE'
  362. END
  363. UnlockGUI
  364.  
  365. EXIT 0
  366.  
  367.  
  368.  
  369.  
  370. ParseText: PROCEDURE EXPOSE tchar. tpen.
  371.  
  372.     tstring = ARG(1)
  373.     tpn = ARG(2)
  374.     tlen = LENGTH(tstring)
  375.     tpos = 1
  376.     tnum = 0
  377.  
  378.     DO UNTIL tpos > tlen
  379.         td = SUBSTR(tstring, tpos, 1)
  380.         tnewpen = ''
  381.         IF td = '[' THEN DO    /* [###] */
  382.             tnewpos = tpos + 1
  383.             IF SUBSTR(tstring, tnewpos, 1) = '[' THEN
  384.                 tpos = tpos + 1
  385.             ELSE DO
  386.                 DO FOREVER
  387.                     tc = SUBSTR(tstring, tnewpos, 1)
  388.                     IF tc < '0' | tc > '9' THEN
  389.                         LEAVE
  390.                     tnewpen = tnewpen || tc
  391.                     tnewpos = tnewpos + 1
  392.                 END
  393.             END
  394.         END
  395.         ELSE IF C2D(td) = 27 THEN DO    /* Esc[3###m */
  396.             IF SUBSTR(tstring, tpos+1, 2) == '[3' THEN DO
  397.                 tnewpos = tpos + 3
  398.                 DO FOREVER
  399.                     tc = SUBSTR(tstring, tnewpos, 1)
  400.                     IF tc < '0' | tc > '9' THEN
  401.                         LEAVE
  402.                     tnewpen = tnewpen || tc
  403.                     tnewpos = tnewpos + 1
  404.                 END
  405.             END
  406.         END
  407.         ELSE IF td = '"' THEN
  408.             td = '""'
  409.  
  410.         IF tnewpen == '' THEN DO
  411.             tnum = tnum + 1
  412.             tchar.tnum = td
  413.             tpen.tnum = tpn
  414.             tpos = tpos + 1
  415.         END
  416.         ELSE DO
  417.             tpn = tnewpen
  418.             tpos = tnewpos + 1
  419.         END
  420.     END
  421.  
  422.     RETURN tnum
  423.  
  424.  
  425.  
  426.  
  427. SaveSet: PROCEDURE
  428.  
  429.     sname = ARG(1)
  430.     val = ARG(2)
  431.  
  432.     IF OPEN('settingfile', 'ENV:PP_Whirlpool_'sname, 'W') THEN DO
  433.         CALL WRITECH('settingfile', val)
  434.         CALL CLOSE('settingfile')
  435.     END
  436.  
  437.     RETURN
  438.  
  439.  
  440.  
  441.  
  442. LoadSet: PROCEDURE
  443.  
  444.     sname = ARG(1)
  445.     def_val = ARG(2)
  446.     IF ARG() > 2 THEN
  447.         global_set = ARG(3)
  448.     ELSE
  449.         global_set = 0
  450.     IF ARG() > 3 THEN
  451.         request_quote = ARG(4)
  452.     ELSE
  453.         request_quote = 1
  454.  
  455.     val = def_val
  456.     IF global_set THEN
  457.         set_fname = 'ENV:'sname
  458.     ELSE
  459.         set_fname = 'ENV:PP_Whirlpool_'sname
  460.  
  461.     IF OPEN('settingfile', set_fname, 'R') THEN DO
  462.         val = READCH('settingfile', 65535)
  463.         CALL CLOSE('settingfile')
  464.     END
  465.  
  466.     IF request_quote THEN DO
  467.         /* encode quotes for the Request command ('"' -> '\""') */
  468.         qpos_start = 1
  469.         DO FOREVER
  470.             qpos = INDEX(val, '"', qpos_start)
  471.             IF qpos = 0 THEN BREAK
  472.             val = INSERT('\"', val, qpos-1)
  473.             qpos_start = qpos + 3
  474.         END
  475.     END
  476.  
  477.     RETURN val
  478.  
  479.  
  480.  
  481.  
  482. Break_C:
  483.  
  484.     SetPen 'FOREGROUND' savepen
  485.     FreeBrush 'FORCE'
  486.     UnlockGUI
  487.  
  488.     RETURN
  489.